home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / ofix5.t < prev    next >
Text File  |  1993-07-09  |  7KB  |  171 lines
  1. (herald ofix5 (syntax-table (env-syntax-table orbit-env)))
  2.  
  3. ;;; from $BACK_END/closure.t
  4.  
  5. (define (close-analyze-label node heapenv heapvia)
  6.   (let* ((live (lambda-live node))
  7.          (need-contour? (eq? (lambda-env node) 'needs-link))
  8.          (b (variable-binder heapvia))
  9.          (via (if (or (lambda-live b)
  10.               (known-lambda? b)
  11.               (neq? (lambda-strategy b) strategy/heap))
  12.                   *top-level-lambda* 
  13.                   heapvia)))
  14.     (set (lambda-env node) (create-join-point live via need-contour?))
  15.     (walk (lambda (var) (set (variable-definition var) 'many)) live)
  16.     (close-analyze-body (lambda-body node) '() via '() via)))
  17.  
  18. ;;; from $BACK_END/lookup.t
  19.  
  20. (define (access-value node value)
  21.   (cond ((and (variable? value)
  22.           (not (variable-binder value))
  23.           (var-is-vcell? value))
  24.      (let ((acc (lookup node (get-lvalue value) nil)))
  25.        (let ((reg (get-register 'pointer node '*)))
  26.          (generate-move acc reg)
  27.          (set (reg-node reg) -1)
  28.          (reg-offset reg 2))))
  29.     (else
  30.      (really-access-value node value))))
  31.  
  32. ;;; from $BACK_END/parassign.t
  33.  
  34. (define (do-assignment movers node)
  35.   (iterate loop1 ((movers movers)
  36.                   (targets (map arg-mover-to movers))
  37.                   (temp nil))
  38.     (cond ((null? movers))
  39.         (else
  40.          (iterate loop2 ((candidates targets))
  41.            (cond ((null? candidates)
  42.                   (let ((mover (car movers)))
  43.                     (generate-move (arg-mover-to mover)
  44.                                    (reg-offset TASK
  45.                                      (if (eq? (reg-type (arg-mover-to mover))
  46.                           'pointer)
  47.                                           task/extra-pointer
  48.                                           task/extra-scratch)))
  49.                     (really-rep-convert node
  50.                                         (arg-mover-from mover)
  51.                                         (arg-mover-from-rep mover)
  52.                                         (arg-mover-to mover)
  53.                                         (arg-mover-to-rep mover))
  54.                     (loop1 (cdr movers)
  55.                            (delq (arg-mover-to mover) targets)
  56.                            (arg-mover-to mover))))
  57.                  ((not (mem? from-reg-eq? (car candidates) movers))
  58.                   (let ((mover (car (mem to-reg-eq? (car candidates) movers))))
  59.                     (really-rep-convert node
  60.                          (cond ((eq? (arg-mover-from mover) temp)
  61.                                 (if (eq? (reg-type (arg-mover-from mover))
  62.                      'pointer)
  63.                                     (reg-offset TASK task/extra-pointer)
  64.                                     (reg-offset TASK task/extra-scratch)))
  65.                                (else
  66.                                 (arg-mover-from mover)))
  67.                          (arg-mover-from-rep mover)
  68.                          (arg-mover-to mover)
  69.                          (arg-mover-to-rep mover))
  70.                     (loop1 (delq mover movers)
  71.                            (delq (arg-mover-to mover) targets)
  72.                            temp)))
  73.                  (else
  74.                   (loop2 (cdr candidates)))))))))
  75.  
  76. ;;; from $BACK_END/bookkeep.t
  77. (define (kill-if-dead node where)
  78.   (cond ((lambda-node? node)
  79.          (walk (lambda (var)
  80.                  (if (not (or (memq? var (lambda-live where))
  81.                               (fx= (variable-number var) 0)))
  82.                      (kill var)))
  83.                (lambda-live node)))
  84.         (else
  85.      (let ((var (leaf-value node)))
  86.        (cond ((not (variable? var))
  87.           (kill var))
  88.          (else
  89.           (let ((var (cond ((variable-known var) => lambda-self-var)
  90.                    (else var))))
  91.             (if (not (memq? var (lambda-live where)))
  92.             (kill var)))))))))
  93.  
  94. ;;; from $FRONT_END/fixup.t send to hunt
  95.  
  96. (define (fix-exit-reference var node value)
  97.   (let ((proc (call-proc (node-parent node))))
  98.     (cond ((eq? node proc)
  99.            (return))
  100.           ((not (primop-node? proc))
  101.            (introduce-exit-lambda var node value '#t))
  102.           ((eq? primop/y (primop-value proc))
  103.            (introduce-exit-lambda var node value '#t))
  104.           (else
  105.            (replace-with-lambda
  106.             node
  107.             (primop.values-returned
  108.              (primop-value (call-proc (node-parent node)))))))))
  109.  
  110.  
  111. ;;; from $BACK_END/reg.t 
  112.  
  113. (define (allocate-location node prim)
  114.   (let ((c (cont node)))
  115.     (if (and (lambda-node? c)
  116.              (let ((refs (variable-refs (car (lambda-variables c)))))
  117.                (and refs
  118.                     (null? (cdr refs))
  119.                     (eq? c (node-parent (node-parent (car refs))))
  120.             (let ((proc (call-proc (lambda-body c))))
  121.               (and (primop-node? proc)
  122.                (neq? (primop-value proc) primop/make-cell)))
  123.                     (reps-compatable? 
  124.                       (primop.rep-wants (leaf-value ((call-arg 2) node)))
  125.                       (variable-rep (car (lambda-variables c)))))))
  126.         (generate-location-access node)
  127.         (really-allocate-primop-call node prim))))
  128.  
  129. (define (introduce-cell var)
  130.   (let ((node (variable-binder var))
  131.         (new-var (create-variable (variable-name var))))
  132.     (hack-references var new-var)
  133.     (let-nodes ((call (($ primop/make-cell) 1 (^ cont1)))
  134.                  (cont1 (() (v new-var))
  135.                    (($ primop/set-location) 1
  136.                     (^ cont2) ($ primop/cell-value) (* var) (* new-var)))
  137.                   (cont2 (#f) ()))
  138.       (cond ((primop-ref? (call-proc (lambda-body node))
  139.               primop/remove-state-object)
  140.          (insert-call call cont2 (car (call-args (lambda-body node)))))
  141.         (else
  142.          (insert-call call cont2 node))))))
  143.  
  144.     (define (add-side-effects name)
  145.       (let* ((def (base-early-binding-env name))
  146.              (primop (vref (definition-value def) 0))
  147.              (mask (table-entry primop-predicate-table 'primop.side-effects?)))
  148.         (modify (%primop-bitv primop)
  149.                 (lambda (x) (fixnum-logior x 2)))))
  150.  
  151.     (add-side-effects 'receive-values)
  152.  
  153. #|
  154. ;Real Fix - change this in DECLARE.T in the front-end:
  155.  
  156.     (define-declaration (simplifier name exp) (shape)
  157.       (cond ((new-env-definition shape name)
  158.              => (lambda (def)
  159.                   (let* ((clauses `(((primop.simplify self node) (,exp node))
  160.                                     ((primop.side-effects? self) '#t)
  161.                                     ((primop.integrate? self node) nil)))
  162.                          (primop (eval (primop-code name '() clauses) orbit-env)))
  163.                     (set (primop.source primop) clauses)
  164.                     (add-new-primop shape primop)
  165.                     (set (definition-value def)
  166.                          (node->vector (create-primop-node primop))))))
  167.             (else
  168.              (missing-declaration-variable-warning name 'simplifier))))
  169.  
  170.  
  171. |#